perm filename BGEN.F4[1,MUS] blob
sn#081800 filedate 1974-01-11 generic text, type C, neo UTF8
COMMENT ā VALID 00004 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00004 00003 ACCEPT 201,AB
C00006 00004 IY=FUN(I)*100.
C00007 ENDMK
Cā;
SUBROUTINE GEN(FUN)
C AFTER 'SYNTH(F1);' TYPE 99= TO USE H,A,P,K: ALL OTHER
C NUMBERS = H,A ONLY. TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
DIMENSION FUN(100),A(512)
COMMON FREQ(3,0/50,100),FUNC(100),AMP(100),II(1),IJJ(4000)
TYPE 499
ACCEPT 201,AB
IF(AB.EQ.0)GO TO 999
4000 TYPE 500
ACCEPT 501,FILE
IF(LOOKD(FILE).GE.0)GO TO 4000
CALL IFILE(1,FILE)
553 TYPE 502
ACCEPT 501,FN
DO 550 I=1,2
550 READ(1,501),TS1
551 READ(1,504,END=553),TS1,TS2,FK
555 IF(FN.NE.FK)GO TO 551
552 READ(1,505),TS1,TS2
556 IF(TS2.LE.100)GO TO 552
READ(1,506),(A(K),K=1,512)
IXCT=1
XCT=1.0
XINC=512./100.
DO 560 J=1,100
FUN(J)=A(IXCT)
XCT=XCT+XINC
560 IXCT=XCT
GO TO 446
499 FORMAT(' TYPE 1 FOR FUN ON DSK, ELSE CR'/)
500 FORMAT(' TYPE FILE NAME'/)
501 FORMAT(A5)
502 FORMAT(' TYPE FUNCTION NAME'/)
504 FORMAT(2(A5,A1))
505 FORMAT(2F)
506 FORMAT(8F)
999 TYPE 1002
1002 FORMAT(' CR TO CLEAR ELSE 1'/)
ACCEPT 201,AB
IF(AB.NE.0.0)GO TO 1001
DO 15 I=1,100
15 FUN(I)=0.0
201 FORMAT(4F)
1001 FAC=360./100.
16 CALL DPYSET(1,IJJ,3000)
CALL ALINE(0,0,200,0)
CALL ALINE(0,100,0,0)
TYPE 445
445 FORMAT(' TYPE H,A,P,K OR CR'/)
ACCEPT 201,H,AMPL,X,CON
IF(H.LE.0.0)GO TO 446
X=X*100./360.
2016 DO 17 J=1,100
XK=SIND(X*FAC)*AMPL+CON
IF(CON.LT.100.0)GO TO 1
FUN(J)=(XK-100.)*FUN(J)
GO TO 2
1 FUN(J)=FUN(J)+XK
2 X=X+H
IY=FUN(J)*100.
IX=J*2
CALL AVECT(IX,IY)
IF(X.LE.50.)GO TO 17
X=X-100.
17 CONTINUE
CALL DPYOUT(1)
GO TO 16
446 CALL DPYSET(1,IJJ,3000)
CALL ALINE(0,0,200,0)
CALL ALINE(0,100,0,0)
2200 X=FUN(1)
DO 19 I=2,100
H=ABS(FUN(I))
19 IF(X.LT.H)X=H
DO 20 I=1,100
FUN(I)=FUN(I)/X
IY=FUN(I)*100.
IX=(I-1)*2
20 CALL AVECT(IX,IY)
CALL DPYOUT(1)
TYPE 97
97 FORMAT(' CR TO FINISH OR 1 TO ADD MORE'/)
ACCEPT 201,ZZZ
IF(ZZZ.EQ.1.)GO TO 999
CALL HYDPOG(1)
RETURN
END